From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 03:23:35 +0000 (-0800)
Subject: *mplement object-tagger.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~215
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=da610806f103bbfeaa36f419ae4f332e3e6d4a75;p=mit-scheme.git

*mplement object-tagger.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 467152d5a..9d4f4b4a1 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3597,6 +3597,7 @@ USA.
   (parent (runtime))
   (export ()
 	  guarantee-tagged-object
+	  object-tagger
 	  set-tagged-object-unparser-method!
 	  tag-object
 	  tagged-object-datum
diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index 7efcd7bd1..fec5f84da 100644
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -35,12 +35,20 @@ USA.
 (define (tagged-object? object)
   (fix:= (object-type object) tagged-object-type))
 
+(define (object-tagger predicate)
+  (let ((tag (predicate->tag predicate)))
+    (lambda (datum)
+      (make-tagged-object tag datum))))
+
 (define (tag-object predicate datum)
-  (system-pair-cons tagged-object-type (predicate->tag predicate) datum))
+  (make-tagged-object (predicate->tag predicate) datum))
 
 (define (tagged-object-predicate object)
   (tag->predicate (tagged-object-tag object)))
 
+(define-integrable (make-tagged-object tag datum)
+  (system-pair-cons tagged-object-type tag datum))
+
 (define (tagged-object-tag object)
   (guarantee tagged-object? object 'tagged-object-tag)
   (system-pair-car object))