Make sure that tagged vector/pair predicates are registered.

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index fdb65328e684f30f20dbeb0f48db82f66cb9f2f9..960c3c91f9f8070542dceeff33b88a21e8fbc0ea 100644 (file)
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -758,27 +758,34 @@ differences:
     (if predicate-name
        (let* ((context (structure/context structure))
               (tag-expression
-               (close (structure/tag-expression structure) context)))
+               (close (structure/tag-expression structure) context))
+              (name (parser-context/name context)))
          (case (structure/physical-type structure)
-           ((RECORD)
-            `((DEFINE ,predicate-name
-                (,(absolute 'RECORD-PREDICATE context)
+           ((record)
+            `((define ,predicate-name
+                (,(absolute 'record-predicate context)
                  ,(close (structure/type-descriptor structure) context)))))
-           ((VECTOR)
-            `((DEFINE (,predicate-name OBJECT)
-                (AND (,(absolute 'VECTOR? context) OBJECT)
-                     (,(absolute 'NOT context)
-                      (,(absolute 'ZERO? context)
-                       (,(absolute 'VECTOR-LENGTH context) OBJECT)))
-                     (,(absolute 'EQ? context)
-                      (,(absolute 'VECTOR-REF context) OBJECT 0)
-                      ,tag-expression)))))
-           ((LIST)
-            `((DEFINE (,predicate-name OBJECT)
-                (AND (,(absolute 'PAIR? context) OBJECT)
-                     (,(absolute 'EQ? context)
-                      (,(absolute 'CAR context) OBJECT)
-                      ,tag-expression)))))))
+           ((vector)
+            `((define (,predicate-name object)
+                (and (,(absolute 'vector? context) object)
+                     (,(absolute 'not context)
+                      (,(absolute 'zero? context)
+                       (,(absolute 'vector-length context) object)))
+                     (,(absolute 'eq? context)
+                      (,(absolute 'vector-ref context) object 0)
+                      ,tag-expression)))
+              (,(absolute 'register-predicate! context)
+               ,predicate-name ',name
+               '<= ,(absolute 'vector? context))))
+           ((list)
+            `((define (,predicate-name object)
+                (and (,(absolute 'pair? context) object)
+                     (,(absolute 'eq? context)
+                      (,(absolute 'car context) object)
+                      ,tag-expression)))
+              (,(absolute 'register-predicate! context)
+               ,predicate-name ',name
+               '<= ,(absolute 'pair? context))))))
        '())))
 \f
 (define (type-definitions structure)