+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass event-class (boxed-class)
+ ((event-type :reader event-class-type)))
+
+ (defmethod validate-superclass ((class event-class) (super standard-class))
+ ;(subtypep (class-name super) 'event)
+ t))
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+ (let ((class-name (or name (class-name class))))
+ (unless (eq class-name 'event)
+ (register-type-alias class-name 'event)))
+ (call-next-method)
+ (setf (slot-value class 'event-type) (first type))
+ (setf (gethash (first type) *event-classes*) class))
+
+(let ((reader (reader-function 'event-type)))
+ (defun %event-class (location)
+ (gethash (funcall reader location 0) *event-classes*)))
+
+(defmethod make-proxy-instance :around ((class event-class) location &rest initargs)
+ (declare (ignore class))
+ (let ((class (%event-class location)))
+ (apply #'call-next-method class location initargs)))
+
+
+;;;;