From b3e6401cdba421f7fdfce774a853263371e21090 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 2 Dec 2018 02:45:35 +0000
Subject: [PATCH] Rework vector tag printer methods so they work again.

XXX Needs tests, but these are a pain to construct...
---
 src/compiler/base/object.scm | 56 ++++++++++++++++++++++--------------
 1 file changed, 34 insertions(+), 22 deletions(-)

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 34f84b607..949493454 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -29,11 +29,13 @@ USA.
 (declare (usual-integrations))
 
 (define-structure (vector-tag
-		   (constructor %make-vector-tag (parent name index noop)))
+		   (constructor %make-vector-tag
+				(parent name index predicate noop)))
   (parent false read-only true)
   (name false read-only true)
   (index false read-only true)
   (description false)
+  (predicate false read-only true)
   (method-alist '())
 
   ;; This property was stored in the method alist, but it is used so
@@ -42,30 +44,40 @@ USA.
   )
 
 (define make-vector-tag
-  (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
-    (define-print-method (lambda (object)
-			   (and (vector? object)
-				(fix:> (vector-length object) 0)
-				(eq? root-tag (vector-ref object 0))))
-      (standard-print-method
-       (lambda (object)
-	 (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+  (let ()
+    (define (root-tagged-vector? object)
+      (and (vector? object)
+	   (fix:> (vector-length object) 0)
+	   (eq? root-tag (vector-ref object 0))))
+    (define root-tag
+      (%make-vector-tag false 'OBJECT false root-tagged-vector? false))
+    (register-predicate! root-tagged-vector? 'root-tagged-vector?
+			 '<= vector?)
     (named-lambda (make-vector-tag parent name enumeration)
-      (%make-vector-tag (or parent root-tag)
-			name
-			(and enumeration
-			     (enumeration/name->index enumeration
-						      name))
-			;; Propagate this downward at construction time
-			;; to avoid having to crawl upward at use time.
-			(and parent (vector-tag-noop parent))))))
+      (define (predicate object)
+	(and (vector? object)
+	     (fix:> (vector-length object) 0)
+	     (eq? tag (vector-ref object 0))))
+      (define tag
+	(%make-vector-tag (or parent root-tag)
+			  name
+			  (and enumeration
+			       (enumeration/name->index enumeration
+							name))
+			  predicate
+			  ;; Propagate this downward at construction time
+			  ;; to avoid having to crawl upward at use time.
+			  (and parent (vector-tag-noop parent))))
+      (register-predicate! predicate (symbol name '?)
+			   '<= (vector-tag-predicate (or parent root-tag)))
+      (define-print-method predicate
+	(standard-print-method
+	 (lambda (object)
+	   (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+      tag)))
 
 (define (define-vector-tag-unparser tag unparser)
-  (define-print-method (lambda (object)
-			 (and (vector? object)
-			      (fix:> (vector-length object) 0)
-			      (eq? tag (vector-ref object 0))))
-    unparser)
+  (define-print-method (vector-tag-predicate tag) unparser)
   (vector-tag-name tag))
 
 (define (vector-tag-put! tag key value)
-- 
2.25.1