From 2673b89af3b80e5bdd57112e7789d99fe04c5b6d Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@interchange.ubc.ca>
Date: Wed, 10 Aug 2011 18:34:51 -0400
Subject: [PATCH] Added a match expander for objects in unstable.

original commit: d12b617292c284c4a4c18cf926b198487a8c070a
---
 collects/unstable/match.rkt | 29 +++++++++++++++++++++++++++--
 1 file changed, 27 insertions(+), 2 deletions(-)

diff --git a/collects/unstable/match.rkt b/collects/unstable/match.rkt
index 2f07528e..3fb84b6f 100644
--- a/collects/unstable/match.rkt
+++ b/collects/unstable/match.rkt
@@ -1,8 +1,11 @@
 #lang racket/base
 
-(require racket/match (for-syntax racket/base))
+(require racket/class
+         racket/match
+         (for-syntax racket/base)
+         (for-syntax syntax/parse))
 
-(provide == match? as)
+(provide == match? as object)
 
 (define-match-expander
   ==
@@ -18,3 +21,25 @@
 (define-match-expander as
   (syntax-rules ()
     [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)]))
+
+;; Added by asumu
+;; Match expander for objects from racket/class
+(define-match-expander object
+  (λ (stx)
+    (define-syntax-class field
+      #:attributes (name pat)
+      (pattern
+        ((~datum field)
+         name
+         (~optional pat #:defaults ([pat #'name])))))
+
+    (syntax-parse stx
+      [(object f:field ...)
+       #'(and (? object?)
+              (and (? (λ (o) (field-bound? f.name o)))
+                   (app (λ (o) (get-field f.name o))
+                        f.pat))
+              ...)]
+      [(object class f:field ...)
+       #'(and (? (λ (o) (is-a? o class)))
+              (object f ...))])))