- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
+
+(define (%make-condition-type layout id parent all-fields)
+ (let ((struct (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields)))
+
+ ;; Hack to associate STRUCT with a name, providing a better name for
+ ;; GOOPS classes as returned by `class-of' et al.
+ (set-struct-vtable-name! struct (cond ((symbol? id) id)
+ ((string? id) (string->symbol id))
+ (else (string->symbol ""))))
+ struct))