From d92ce41a6f00c9219cd8213ca2df39907d6c8236 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 13 Dec 2010 18:40:06 -0500
Subject: [PATCH] Make 2htdp/image produce png-convertible results.

---
 collects/2htdp/tests/test-image.rkt |  4 ++++
 collects/mrlib/image-core.rkt       | 26 ++++++++++++++++++++++++--
 2 files changed, 28 insertions(+), 2 deletions(-)

diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt
index 060f9799c1..4760ef595b 100644
--- a/collects/2htdp/tests/test-image.rkt
+++ b/collects/2htdp/tests/test-image.rkt
@@ -51,6 +51,7 @@
          racket/port
          wxme
          rackunit
+         file/convertible
          (only-in lang/imageeq image=?)
          (prefix-in 1: htdp/image)
          (only-in lang/htdp-advanced equal~?))
@@ -2051,6 +2052,9 @@
         =>
         #f))
 
+(test (convertible? (circle 20 "solid" "red")) => #t)
+(test (bytes? (convert (circle 20 "solid" "red") 'png-bytes)) => #t)
+
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index ee44c87e8a..b95c8314ee 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -36,7 +36,8 @@ has been moved out).
          "private/image-core-snipclass.rkt"
          "private/regmk.rkt"
          (prefix-in cis: "cache-image-snip.ss")
-         (for-syntax racket/base))
+         (for-syntax racket/base)
+         file/convertible)
 
 
 
@@ -197,8 +198,29 @@ has been moved out).
 (define skip-image-equality-fast-path (make-parameter #f))
 (define render-normalized (make-parameter #f))
 
+(define png-convertible<%>
+  (interface* ()
+              ([prop:convertible
+                (lambda (img format default)
+                  (case format
+                    [(png-bytes)
+                     (let ([s (open-output-bytes)])
+                       (send (to-bitmap (to-img img)) save-file s 'png)
+                       (get-output-bytes s))]
+                    [else default]))])))
+
+(define (to-bitmap img)  
+  (let* ([bb (send img get-bb)]
+         [bm (make-object bitmap% 
+               (add1 (inexact->exact (ceiling (bb-right bb)))) 
+               (add1 (inexact->exact (ceiling (bb-bottom bb)))))]
+         [bdc (make-object bitmap-dc% bm)])
+    (send bdc clear)
+    (render-image img bdc 0 0)
+    (send bdc get-bitmap)))
+	     
 (define image%
-  (class* snip% (equal<%> image<%>)
+  (class* snip% (png-convertible<%> equal<%> image<%>)
     (init-field shape bb normalized? pinhole)
     (define/public (equal-to? that eq-recur)
       (or (eq? this that)