+ (defmethod validate-superclass ((class event-class) (super standard-class))
+ (subtypep (class-name super) 'event)))
+
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+ (call-next-method)
+ (setf (slot-value class 'event-type) (first type))
+ (setf (gethash (first type) *event-classes*) class)
+ (let ((class-name (or name (class-name class))))
+ (register-type class-name 'event)))