The type object being constructed for named structures of type LIST

was incorrect.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 698bdb89a83d6e355440a2cfc06a77dca079d5b6..94a41f70966eebe078f2e6ffca732b1a85dafa33 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 1.5 1987/12/08 14:01:05 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 1.6 1987/12/10 21:52:18 cph Exp $
 ;;;
 ;;;    Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -533,24 +533,23 @@ functionality is not implemented.
      (write (hash structure-instance)))))
 \f
 (define (make-structure-type structure tag)
-  (let ((type
-        (make-sub-type
-         (structure/name structure)
-         (microcode-type-object 'vector)
-         (case (structure/scheme-type structure)
-           ((VECTOR)
-            (lambda (vector)
-              (and (not (zero? (vector-length vector)))
-                   (eq? (vector-ref vector 0) tag))))
-           ((LIST)
-            (lambda (pair)
-              (eq? (car pair) tag)))
-           (else
-            (error "Unknown scheme type" structure))))))
-    (if (not tag)
-       (set! tag type))
-    (2d-put! tag tag->structure structure)
-    type))
+  (let ((scheme-type (structure/scheme-type structure)))
+    (let ((type
+          (make-sub-type
+           (structure/name structure)
+           (microcode-type-object scheme-type)
+           (case scheme-type
+             ((VECTOR)
+              (lambda (vector)
+                (and (not (zero? (vector-length vector)))
+                     (eq? (vector-ref vector 0) tag))))
+             ((LIST)
+              (lambda (pair)
+                (eq? (car pair) tag)))
+             (else
+              (error "Unknown scheme type" structure))))))
+      (2d-put! (or tag type) tag->structure structure)
+      type)))
 
 (define (structure-instance->description structure)
   (2d-get (cond ((and (vector? structure)